home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / 2924.ZIP / DMLXREF.ARC / XREF.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-12-28  |  30.3 KB  |  1,136 lines
  1. {.PO 10}
  2.  
  3. {$M 65520,16384,655360}   { Lots of Stack for Recursion, Lots of Heap for ID tree }
  4.  
  5. PROGRAM XRefForTurboOrMicrosoftPascal;
  6.  
  7. {$I XREF.DOC}             (* READ THE DOCUMENTATION *)
  8.  
  9. USES
  10.   CRT, DML, HEAPTREE;
  11.  
  12. CONST
  13.    Ver             = '1.00';
  14.    IncCount        : WORD = 0;
  15.  
  16. VAR
  17.    FileDateAndTime     : STRING;
  18.    MainFileDateAndTime : STRING;
  19.    Today               : STRING;
  20.    Footing             : STRING;
  21.    Heading             : STRING;
  22.    Margin              : INTEGER;    { set by .PO }
  23.    LangType            : BYTE;
  24.    ExitSave            : POINTER;
  25.  
  26. CONST
  27.    MaxIds      = 1000;
  28.    MaxIdLen    = 30;
  29.    ff          = ^L;
  30.    Sec         = 64;
  31.    RecLen      = 128;
  32.    MaxSec      = Sec*RecLen;
  33.    NumLen      =  7;        { Xref line # field width }
  34.  
  35. TYPE
  36.    FileType  = file;
  37.    IdStgType = String [MaxIdLen];
  38.    InStgType = array [1..MaxSec] of char;
  39.    CharSet   = set of char;
  40.    DTstgType = string [18];
  41.  
  42.    NodeType = ^NodeRecord;
  43.  
  44.    NodeRecord = Record
  45.       Data : integer;
  46.       Next : NodeType;
  47.       end;
  48.  
  49.    FNRec = Record
  50.        Last : NodeType;
  51.        Next : NodeType;
  52.        end;
  53.  
  54.    FirstNodeType = array [1..MaxIds] of FNRec;
  55.  
  56. CONST
  57.    UseMainFile : boolean     = true;
  58.    UnGetFlag   : boolean     = false;
  59.    IdChar      : CharSet     = ['a'..'z', 'A'..'Z', '_', '^'];
  60.    IdNum       : CharSet     = ['0'..'9'];
  61.    Listing     : boolean     = true;
  62.    MaxPageLine : integer     = 52;
  63.  
  64. VAR
  65.    MainFileName    : STRING;
  66.    IncludeFileName : STRING;
  67.    MainFile        : FileType;
  68.    IncludeFile     : FileType;
  69.    FileName        : STRING;
  70.  
  71.    SaveCh,
  72.    ch              : char;
  73.    SavePntr,
  74.    Pntr            : integer;
  75.    SaveInStg,
  76.    InStg           : InStgType;
  77.    SaveEndOfLine,
  78.    EndOfLine       : boolean;
  79.  
  80.    outfile    : text;
  81.    LineNumber : integer;
  82.    PageNumber : integer;
  83.    PageLine   : integer;
  84.    id         : IdStgType;
  85.    outstg     : string[132];
  86.    Nu         : integer;       (* current number of line numbers per line *)
  87.    DateTime   : DTstgType;
  88.  
  89.    Xref       : IndexFile;
  90.    LastNode   : NodeType;
  91.    NextNode   : Nodetype;
  92.    OldLastNode: NodeType;
  93.    FirstNode  : FirstNodeType;
  94.    Nptr       : integer;
  95.    FreeNptr   : integer;
  96.  
  97. PROCEDURE IsTextFile (FName : STRING);
  98.  
  99. VAR
  100.   InFile : FILE OF BYTE;
  101.   EOF    : BYTE;
  102.   IORes  : WORD;
  103.  
  104. BEGIN
  105.   ASSIGN(InFile,FName);
  106.   {$I-} RESET(InFile); {$I+}
  107.   IORes := IORESULT;
  108.   IF IORes <> 0 THEN BEGIN
  109.     WRITELN('Problem # ',IORes,' opening File: ',FName);
  110.     HALT(100);
  111.     END;
  112.   SEEK(InFile,FILESIZE(Infile)-1);
  113.   READ(InFile,EOF);
  114.   IF NOT (EOF = ORD(^Z)) THEN BEGIN
  115.       WRITELN(^G);
  116.       WRITELN('-- "',FName, '" --');
  117.       WRITELN('doesn''t appear to be a text file and');
  118.       WRITELN('doesn''t terminate with a ^Z and cannot be processed by Xref.');
  119.       WRITELN;
  120.       WRITELN('Try adding a Ctrl-Z to the end of the file, if it is a text file.');
  121.       WRITELN('Xref program aborted.  (ERRORLEVEL = 4)');
  122.       WRITELN;
  123.       CLOSE(OutFile);
  124.       HALT(4);
  125.       END;
  126.     CLOSE(InFile);
  127. END;
  128.  
  129. {.pa}
  130. {----------------------------------------------------------------}
  131.  
  132. Procedure InitResvWords;
  133. CONST
  134.    NumRwd = 48;
  135.  
  136. TYPE
  137.    RwdType = array [1..2,1..NumRwd] of String[9];
  138.  
  139. Const
  140.    Rwd : RwdType = (
  141.                     ('ABSOLUTE','AND','ARRAY','BEGIN','CASE','CONST','DIV',
  142.                     'DO','DOWNTO','ELSE','END','EXTERNAL','FILE','FOR',
  143.                     'FORWARD','FUNCTION','GOTO','IF','IMPLEMENTATION','IN',
  144.                     'INLINE','INTERFACE','INTERRUPT','LABEL',
  145.                     'MOD','NIL','NOT','OF','OR','PACKED','PROCEDURE',
  146.                     'PROGRAM','RECORD','REPEAT','SET','SHL','SHR','STRING',
  147.                     'THEN','TO','TYPE','UNIT',
  148.                     'UNTIL','USES','VAR','WHILE','WITH','XOR'),
  149.  
  150.                     ('AND','ARRAY','BEGIN','BREAK','CASE','CONST','CYCLE','DIV',
  151.                     'DO','DOWNTO','ELSE','END','EXTERN','FILE','FOR',
  152.                     'FORWARD','FUNCTION','GOTO','IF','IMPLEMENTATION','IN',
  153.                     'INTERFACE','LABEL','LSTRING','MOD','MODULE','NIL',
  154.                     'NOT','OF','OR','ORIGIN','OTHERWISE','PACKED','PROCEDURE',
  155.                     'PROGRAM','RECORD','REPEAT','SET',
  156.                     'THEN','TO','TYPE','UNIT',
  157.                     'UNTIL','USES','VAR','WHILE','WITH','XOR'));
  158.  
  159. var
  160.    loop : integer;
  161.  
  162. begin
  163.    for loop := 1 to NumRwd do
  164.       IF Rwd[LangType,Loop] <> '' THEN BEGIN
  165.       Nptr := FreeNptr;
  166.       FreeNptr := FreeNptr + 1;
  167.       New (LastNode);
  168.       FirstNode [Nptr].Last := LastNode;
  169.       FirstNode [Nptr].Next := LastNode;
  170.       LastNode^.data := -10;
  171.       LastNode^.Next := nil;
  172.       AddKey (Xref, Nptr, Rwd [LangType,loop]);
  173.       if Not TreeOK then writeln ('error InitResvWords '+Rwd [LangType,loop]);
  174.       end;
  175. end;
  176.  
  177. {.pa}
  178. {----------------------------------------------------------------}
  179.  
  180. Procedure InitStdIds;
  181. CONST
  182.    NumStd = 154;
  183.  
  184. TYPE
  185.    StdType = array [1..2,1..NumStd] of String[29];
  186.  
  187. Const
  188.    Std : StdType = (
  189.                     ('ABS','ADDR','APPEND','ARCTAN','ASSIGN',
  190.                     'BLACK','BLINK','BLUE','BLOCKREAD',
  191.                     'BLOCKWRITE','BOOLEAN','BROWN','BW40','BW80',
  192.                     'BYTE','C40','C80','CHAR','CHDIR','CHR','CLOSE',
  193.                     'CLREOL','CLRSCR','CONCAT','COPY','COS','CRT','CSEG','CYAN',
  194.                     'DARKGRAY','DEC','DELLINE','DELAY','DELETE','DISPOSE','DOS',
  195.                     'DSEG','EOF','EOLN','ENVCOUNT','ERASE','EXEC',
  196.                     'EXIT','EXITMODE','EXITPROC','EXP',
  197.                     'FALSE','FILEMODE','FILEPOS','FILESIZE','FILLCHAR','FLUSH','FRAC',
  198.                     'FREEMEM','GETDIR','GETMEM','GOTOXY','GRAPH','GREEN','HALT',
  199.                     'HEAPPTR','HI','IORESULT','INC',
  200.                     'INPUT','INSLINE','INSERT','INT','INTEGER','INTR',
  201.                     'KEYPRESSED','LENGTH','LIGHTBLUE','LIGHTCYAN','LIGHTGRAY',
  202.                     'LIGHTGREEN','LIGHTMAGENTA','LIGHTRED','LN','LO',
  203.                     'LONGINT','LOWVIDEO','LST',
  204.                     'MAGENTA','MARK','MAXAVAIL','MAXINT','MEM',
  205.                     'MEMAVAIL','MEMW','MKDIR','MOVE','MSDOS','NEW',
  206.                     'NORMVIDEO','NOSOUND','ODD','OFS','ORD','OVRPATH',
  207.                     'OUTPUT','OVERLAY','PARAMCOUNT','PARAMSTR','PI',
  208.                     'PORT','PORTW','POS','PRED','PREFIXSEG','PRINTER',
  209.                     'PTR','RANDOM','RANDOMIZE',
  210.                     'READ','READKEY','READLN','REAL','RED','RELEASE','RENAME','RESET',
  211.                     'REWRITE','RMDIR','ROUND','SEEK','SEEKEOF','SEEKEOLN',
  212.                     'SEG','SIN','SIZEOF','SOUND','SQR','SQRT','SSEG','STR',
  213.                     'SUCC','SWAP','TEXT','TEXTBACKGROUND','TEXTCOLOR',
  214.                     'TEXTMODE','TRUE','TRUNC','TRUNCATE','UPCASE',
  215.                     'VAL','WHEREX','WHEREY','WHITE','WORD',
  216.                     'WRITE','WRITELN','YELLOW'),
  217.  
  218.                     ('ABORT','ABS','ADR','ADS','APPEND','ARCTAN','ASSIGN',
  219.                     'BOOLEAN','BYTE','CHAR','CHR','CLOSE',
  220.                     'CONCAT','COPY','COPYLST','COPYSTR','COS',
  221.                     'DATE','DECODE','DELETE','DISPOSE','ENCODE',
  222.                     'EOF','EOLN','EVAL','EXP','FALSE','FILLC','FILLCS',
  223.                     'FREECT','GET','HIBYTE','HIWORD',
  224.                     'INPUT','INSERT','INTEGER','INTEGER4',
  225.                     'LN','LOBYTE','LOWER','LOWORD','MARK','MAXINT',
  226.                     'MEMAVL','MOVEL','MOVER','MOVESL','MOVESR','NEW',
  227.                     'ODD','ORD','OUTPUT','PAGE','POSITN','PRED','PUT',
  228.                     'READ','READLN','REAL','REAL8','RELEAS','RESET','RESULT',
  229.                     'RETURN','RETYPE','REWRITE','ROUND','SCANEQ','SCANNE',
  230.                     'SEEK','SIN','SIZEOF','SQR','SQRT',
  231.                     'SUCC','TEXT','TIME','TRUE','TRUNC','UPPER',
  232.                     'WORD','WRITE','WRITELN','WRD',
  233.                     '','','','','','','','','','','','','','','','','','','',
  234.                     '','','','','','','','','','','','','','','','','','','',
  235.                     '','','','','','','','','','','','','','','','','','','',
  236.                     '','','','','','','','','','','','',''));
  237. var
  238.    loop : integer;
  239.  
  240. begin
  241.    for loop := 1 to NumStd do
  242.       IF Std[LangType,Loop] <> '' THEN BEGIN
  243.       Nptr := FreeNptr;
  244.       FreeNptr := FreeNptr + 1;
  245.       New (LastNode);
  246.       FirstNode [Nptr].Last := LastNode;
  247.       FirstNode [Nptr].Next := LastNode;
  248.       LastNode^.data := -20;
  249.       LastNode^.Next := nil;
  250.       AddKey (Xref, Nptr, Std [LangType,loop]);
  251.       if Not TreeOK then writeln ('error InitStdIds '+Std [LangType,loop]);
  252.       end;
  253. end;
  254.  
  255. {.pa}
  256. {----------------------------------------------------------------}
  257.  
  258. PROCEDURE GetFileDate (Name : STRING);
  259. BEGIN
  260.  
  261.    FileDateAndTime := GetFileDateAndTimeString (Name);
  262.  
  263. END;
  264.  
  265. {.pa}
  266. {----------------------------------------------------------------}
  267.  
  268. PROCEDURE NewPage;
  269. VAR
  270.    Loop : INTEGER;
  271. BEGIN
  272.    IF Footing <> '' THEN BEGIN
  273.       FOR Loop := PageLine TO MaxPageLine DO
  274.          WRITELN (OutFile);
  275.       WRITELN (OutFile, Footing);
  276.       END;
  277.  
  278.    PageLine := 1;
  279.    PageNumber := PageNumber + 1;
  280.    WRITE (outfile, ff);
  281.  
  282.    WRITELN (outfile, 'PASCAL XRef V'+Ver+
  283.                          '     Copyright (c) 1989 by DML Software Inc.'+
  284.                          '        Date: '+ Today+
  285.                          '     Page '+I2S(PageNumber,'###@'));
  286.  
  287.  
  288.    WRITE (outfile, 'Main File: '+MainFileName+'  <', MainFileDateAndTime, '>');
  289.  
  290.    IF MainFileName <> FileName THEN BEGIN
  291.       WRITELN (outfile,'    Include File: '+FileName+'  <', FileDateAndTime, '>');
  292.       END
  293.    ELSE
  294.       WRITELN (outfile);
  295.  
  296.       writeln (outfile);
  297.       WRITELN (OutFile, Heading);
  298.       writeln (outfile);
  299. end;
  300.  
  301. {.pa}
  302. {----------------------------------------------------------------}
  303.  
  304. Procedure UnGetChar;
  305. begin
  306.    UnGetFlag := true;
  307. end;
  308.  
  309. {.pa}
  310. {----------------------------------------------------------------}
  311.  
  312. Function GetCharFrom (var InFile : FileType) : char;
  313. VAR
  314.    RecCount : INTEGER;
  315.  
  316.    PROCEDURE DoBlockRead;
  317.    BEGIN
  318.      pntr := 0;
  319.      FILLCHAR(InStg,MaxSec,#0);
  320.      BlockRead (infile, instg, Sec, RecCount);
  321.    END;
  322.  
  323. begin
  324.    if UnGetFlag then begin
  325.       UnGetFlag := false;
  326.       GetCharFrom := UpCase(ch);
  327.       end
  328.    else if not Listing then begin
  329.       if pntr >= MaxSec then DoBlockRead;
  330.       pntr := pntr + 1;
  331.       ch := instg [pntr];
  332.       if ch = chr (13) then begin
  333.          pntr := pntr + 1;
  334.          ch := ' ';
  335.          end;
  336.       if ch = chr (26) then
  337.          ch := chr (0); (* end of file *)
  338.       GetCharFrom := UpCase (ch);
  339.       end
  340.    else begin
  341.       if EndOfLine then begin
  342.          LineNumber := LineNumber + 1;
  343.          EndOfLine := false;
  344.          write (outfile, RJS(I2S(LineNumber,'####@'), Margin+5) + ' ');
  345.          end;
  346.  
  347.       if pntr >= MaxSec then DoBlockRead;
  348.  
  349.       pntr := pntr + 1;
  350.       ch := instg [pntr];
  351.  
  352.       if ch = chr(13) then begin
  353.          EndOfLine := true;
  354.          pntr := pntr + 1;      (* skip linefeed char *)
  355.          ch := ' ';
  356.          end
  357.       else if ch = chr(26) then begin
  358.          EndOfLine := TRUE;
  359.          ch := chr (0);       (* set end of file *)
  360.          end;
  361.  
  362.       GetCharFrom := UpCase (ch);
  363.  
  364.       outstg := outstg + ch;
  365.       if EndOfLine then begin
  366.          writeln (outfile, outstg);
  367.          WRITE;                          { allow Ctrl-Break to work }
  368.          outstg := '';
  369.          PageLine := PageLine + 1;
  370.          if PageLine > MaxPageLine then
  371.             NewPage;
  372.          end;
  373.       end;
  374. end;
  375.  
  376. {.pa}
  377. {----------------------------------------------------------------}
  378.  
  379. Function GetChar : char;
  380. begin
  381.    if UseMainFile then
  382.       GetChar := GetCharFrom (MainFile)
  383.    else
  384.       GetChar := GetCharFrom (IncludeFile);
  385. end;
  386.  
  387. {.pa}
  388. {-------------------------------------------------------------}
  389.  
  390. Procedure OpenInputFile (Filename : IDstgType; var InFile : FileType );
  391.  
  392. var
  393.   OpenErrNum : integer;
  394.   OpenOk     : boolean;
  395.  
  396.   begin
  397.     IsTextFile (FileName);
  398.     GetFileDate (FileName);
  399.     assign(InFile, FileName );
  400.     {$I-} reset(InFile,RecLen); {$I+}
  401.     OpenErrNum := IOresult;
  402.     EndOfLine  := False;
  403.     OpenOK     := ( OpenErrNum = 0 );
  404.     if not OpenOK then
  405.        writeln ('*** Input Open Error #', OpenErrNum );
  406.  
  407. end;
  408.  
  409. {.pa}
  410. {-------------------------------------------------------------}
  411.  
  412. Procedure ChangeBack;
  413. begin
  414.    UseMainFile := True;
  415.    DEC(IncCount);
  416.    Close (IncludeFile);
  417.    ch := SaveCh;
  418.    Pntr := SavePntr;
  419.    Instg := SaveInstg;
  420.    EndOfLine := SaveEndOfLine;
  421.    FileName := MainFileName;
  422.    FileDateAndTime := '';
  423.    NewPage;
  424.    LineNumber := LineNumber + 1;
  425.    write (outfile, RJS(I2S(LineNumber,'####@'), Margin+5) +  ' ');
  426. end;
  427.  
  428. {.pa}
  429. {-------------------------------------------------------------}
  430.  
  431. Procedure FileChange;
  432. begin
  433.    OpenInputFile (IncludeFileName, IncludeFile);
  434.    UseMainFile := False;
  435.    SaveCh := ch;
  436.    SavePntr := Pntr;
  437.    SaveInstg := Instg;
  438.    SaveEndOfLine := EndOfLine;
  439.    FileName := IncludeFileName;
  440.    NewPage;
  441.    Pntr := MaxSec;
  442.    EndOfLine := false;
  443.    LineNumber := LineNumber + 1;
  444.    write (outfile, RJS(I2S(LineNumber,'####@'), Margin+5) +  ' ');
  445. end;
  446.  
  447. {.pa}
  448. {------Function GetId-----------------------------------------}
  449.  
  450. Function GetNextInteger : integer;
  451. var
  452.    temp : String [5];
  453.  
  454. begin
  455.    temp := '';
  456.    ch := GetChar;
  457.    while ch = ' ' do
  458.       ch := GetChar;
  459.    While (ch in ['0'..'9']) and (length (temp) < 5) do begin
  460.       temp := temp + ch;
  461.       ch := GetChar;
  462.       end;
  463.    GetNextInteger := S2I (Temp);
  464. end;
  465.  
  466. {.pa}
  467. {-------------------------------------------------------------}
  468. FUNCTION GetTitleLine : STRING;
  469. VAR
  470.    Temp : STRING;
  471.    Loop : INTEGER;
  472.    Done : BOOLEAN;
  473. BEGIN
  474.    Temp := '';
  475.    REPEAT
  476.       Temp := Temp + GetChar;
  477.       UNTIL EndOfLine;
  478.  
  479.    Done := FALSE;
  480.    Loop := LENGTH (Temp);
  481.    REPEAT
  482.       IF Temp [Loop] = '}' THEN BEGIN
  483.          Done := TRUE;
  484.          Temp := COPY (Temp, 1, Loop - 1);
  485.          END
  486.       ELSE IF Temp [Loop] = ')' THEN BEGIN
  487.          Done := TRUE;
  488.          Temp := COPY (Temp, 1, Loop - 2);
  489.          END
  490.       ELSE BEGIN
  491.          Loop := Loop - 1;
  492.          Done := Loop = 0;
  493.          END;
  494.       UNTIL Done;
  495.    GetTitleLine := Temp;
  496. END;
  497.  
  498. {.pa}
  499. {-------------------------------------------------------------}
  500.  
  501. {------Function GetId-----------------------------------------}
  502.  
  503. Function GetId : IdStgType;
  504. var
  505.    temp      : string[255];
  506.  
  507. {.pa}
  508.  
  509. {------Function GetId-----------------------------------------}
  510.  
  511. Procedure SetMargin;
  512. begin
  513.    if Listing then begin
  514.       Margin := GetNextInteger;
  515.       end;
  516. end;
  517.  
  518. {.pa}
  519. {------Function GetId-----------------------------------------}
  520.  
  521. Procedure PageBreak;
  522. begin
  523.    if Listing then begin
  524.       repeat
  525.          ch := GetChar;
  526.          until EndOfLine;
  527.       NewPage;
  528.    end;
  529. end;
  530.  
  531. {.pa}
  532. {------Function GetId-----------------------------------------}
  533.  
  534. Procedure NewPageIfSpace;
  535. begin
  536.    if Listing then begin
  537.       IF (MaxPageLine - PageLine) < GetNextInteger THEN PageBreak;
  538.       end;
  539. end;
  540.  
  541. {.pa}
  542. {------Function GetId-----------------------------------------}
  543.  
  544. Procedure SetHeading;
  545. begin
  546.    if Listing then begin
  547.       Heading := GetTitleLine;
  548.       end;
  549. end;
  550.  
  551. {.pa}
  552. {------Function GetId-----------------------------------------}
  553.  
  554. Procedure SetFooting;
  555. begin
  556.    if Listing then begin
  557.       Footing := GetTitleLine;
  558.       end;
  559. end;
  560.  
  561.  
  562. {.pa}
  563. {------Function GetId-----------------------------------------}
  564.  
  565. Procedure SetPageLength;
  566. begin
  567.    if Listing then begin
  568.       MaxPageLine := GetNextInteger;
  569.       end;
  570. end;
  571.  
  572. {.pa}
  573.  
  574. Procedure Directive;
  575. VAR
  576.   Include : BOOLEAN;
  577. begin
  578.    Include := FALSE;
  579.    ch := GetChar;
  580.    if ch in ['i', 'I'] then begin
  581.       ch := GetChar;
  582.       IF LangType = 1 THEN { Turbo }
  583.         if NOT (ch IN ['-','+']) then begin
  584.           Include := TRUE;
  585.           while ch = ' ' do ch := GetChar;
  586.           END
  587.         ELSE
  588.       ELSE                 { Microsoft }
  589.         if ch IN ['N','n'] THEN BEGIN
  590.           Include := TRUE;
  591.           while ch <> '''' do ch := GetChar;
  592.           ch := GetChar;
  593.           END;
  594.       IF Include AND KbdScrollLockStatus THEN BEGIN
  595.          IncludeFileName := '';
  596.          while not (ch in ['''',' ', '*', '}', ',']) do begin
  597.             IncludeFileName := IncludeFileName + ch;
  598.             ch := GetChar;
  599.             end;
  600.          INC(IncCount);
  601.          IF IncCount > 1 THEN BEGIN
  602.            WRITELN(^G);
  603.            WRITELN('-- "',IncludeFileName, '" --');
  604.            WRITELN('is nested too deeply');
  605.            WRITELN('Xref program aborted.  (ERRORLEVEL = 5)');
  606.            WRITELN;
  607.            CLOSE(OutFile);
  608.            HALT(5);
  609.            END;
  610.          While not EndOfLine do ch := GetChar;
  611.          FileChange;
  612.          end
  613.  
  614.       else (* not an include *)
  615.          while not EndOfLine do Ch := GetChar;
  616.       end
  617.    else (* not an include *)
  618.       while not EndOfLine do ch := GetChar;
  619. end;
  620.  
  621. {.pa}
  622. {------Function GetId-----------------------------------------}
  623.  
  624. Procedure DotCommand;
  625. begin
  626.    ch := GetChar;
  627.    case ch of
  628.       'p', 'P' : begin
  629.                     ch := GetChar;
  630.                     case ch of
  631.                        'l', 'L' : SetPageLength;
  632.                        'a', 'A' : PageBreak;
  633.                        'o', 'O' : SetMargin;
  634.                        else;
  635.                        end; (* case *)
  636.                     end;
  637.       'c', 'C' : begin
  638.                     ch := GetChar;
  639.                     case ch of
  640.                        'p', 'P' : NewPageIfSpace;
  641.                        else;
  642.                        end; (* case *)
  643.                     end;
  644.       'h', 'H' : begin
  645.                     ch := GetChar;
  646.                     case ch of
  647.                        'e', 'E' : SetHeading;
  648.                        else;
  649.                        end; (* case *)
  650.                     end;
  651.       'f', 'F' : begin
  652.                     ch := GetChar;
  653.                     case ch of
  654.                        'o', 'O' : SetFooting;
  655.                        else;
  656.                        end; (* case *)
  657.                     end;
  658.       'l', 'L' : begin
  659.                     ch := GetChar;
  660.                     case ch of
  661.                        '-' : begin
  662.                                 Repeat
  663.                                    ch := GetChar;
  664.                                    until EndOfLine;
  665.                                 Listing := false;
  666.                                 end;
  667.                        '+' : begin
  668.                                 ch := GetChar;
  669.                                 ch := GetChar;
  670.                                 Listing := true;
  671.                                 while Not EndOfLine do
  672.                                    ch := GetChar;
  673.                                 end;
  674.                        else;
  675.                        end; (* case *)
  676.                     end;
  677.       else;
  678.       end; (* case *)
  679. end;
  680.  
  681. {.pa}
  682. {------Function GetId-----------------------------------------}
  683.  
  684. Procedure ParseComment;
  685. var
  686.    flag : boolean;
  687.  
  688. begin
  689.    ch := GetChar;
  690.    case ch of
  691.       '.' : DotCommand;
  692.  
  693.       '$' : If Listing then Directive;
  694.  
  695.        else begin
  696.                flag := true;
  697.                while (ch <> #0) and (ch <> '}') and flag do begin
  698.                   ch := getchar;
  699.                   if ch = '*' then begin
  700.                      ch := GetChar;
  701.                      if ch = ')' then
  702.                      flag := false;
  703.                      end;
  704.                   end;
  705.                end;
  706.        end; (* case *)
  707.    end;
  708.  
  709. {.pa}
  710. {------Function GetId------- RECURSIVE MEMORY HOG ------------}
  711.  
  712. begin
  713.    ch := GetChar;
  714.    while (ch <> #0) and
  715.          (not (ch in IdChar)) and
  716.          (ch <> '{') and
  717.          (ch <> '$') and
  718.          (ch <> '(') and
  719.          (ch <> '''') do
  720.       ch := GetChar;
  721.  
  722.    case ch of
  723.  
  724.       #0   : begin (* end of file *)
  725.                 if UseMainFile then
  726.                    GetId := '$$eof$$'
  727.                 else begin
  728.                    ChangeBack;
  729.                    GetId := GetId;     { Not an ID, try again }
  730.                    end;
  731.                 end;
  732.  
  733.       '''' : begin (* quoted literal *)
  734.                 ch := GetChar;
  735.                 while (ch <> #0) and (ch <> '''') do
  736.                    ch := GetChar;
  737.                 GetId := '$$FAIL$$';   { Avoid heavy recurssive loop for GetId }
  738.                 end;                   { when doing initialized constant arrays }
  739.  
  740.       '{' : begin  (* easy comment *)
  741.                ParseComment;
  742.                GetId := GetId;         { Not an ID, try again }
  743.                end;
  744.  
  745.       '(' : begin  (* Not so easy comment *)
  746.                ch := GetChar;
  747.                if ch = '*' then begin
  748.                   ParseComment;
  749.                   GetId := GetId;      { Not an ID, try again }
  750.                   end
  751.                else begin
  752.                   UnGetChar;
  753.                   GetId := GetId;      { Not an ID, try again }
  754.                   end;
  755.                end;
  756.  
  757.       '$' : begin  (* Hex number *)
  758.                ch := GetChar;
  759.                while (ch <> #0) and
  760.                      (ch in ['0'..'9', 'a'..'f', 'A'..'F']) do
  761.                   ch := GetChar;
  762.                GetId := GetId;         { Not an ID, try again }
  763.                end;
  764.  
  765.      else  begin                       { An Indentifer }
  766.                temp := '';
  767.                 while (ch <> chr (0)) and
  768.                       ((ch in IdChar) or (ch in IdNum)) do begin
  769.                    temp := temp + ch;
  770.                    ch := GetChar;
  771.                    end;
  772.                 GetId := copy (temp, 1, MaxIdLen);
  773.                 end;
  774.       end; (* case *)
  775.  
  776. end;
  777.  
  778. {.pa}
  779. {-------------------------------------------------------------}
  780.  
  781. Procedure MakeTable;
  782. begin
  783.    repeat
  784.       repeat
  785.         REPEAT
  786.           Id := GetId;
  787.           UNTIL Id <> '$$FAIL$$';              { Avoid heavy recursive loop for init const arrays }
  788.         Until (Listing) or (Id = '$$eof$$');   { Don't add IDs to table unless list on }
  789.       FindKey (Xref, Nptr, Id);
  790.       if TreeOK then begin
  791.          New (LastNode);
  792.          OldLastNode := FirstNode [Nptr].Last;
  793.          OldLastNode^.Next := LastNode;
  794.          FirstNode [Nptr].Last := LastNode;
  795.          LastNode^.Data := LineNumber;
  796.          LastNode^.Next := nil;
  797.          end
  798.       else begin
  799.          Nptr := FreeNptr;
  800.          FreeNptr := FreeNptr + 1;
  801.          New (LastNode);
  802.          FirstNode [Nptr].Last := LastNode;
  803.          FirstNode [Nptr].Next := LastNode;
  804.          LastNode^.Data := LineNumber;
  805.          LastNode^.Next := nil;
  806.          AddKey (Xref, Nptr, Id);
  807.          if Not TreeOK then writeln ('Error MakeTable');
  808.          end;
  809.       until Id = '$$eof$$';
  810. end;
  811.  
  812. {.pa}
  813. {-------------------------------------------------------------}
  814.  
  815. Procedure WriteId (id : IdStgType);
  816. const
  817.    blnks : IdStgType = '                              ';
  818.  
  819. begin
  820.    writeln (outfile);
  821.    if PageLine >= MaxPageLine then begin
  822.       PageLine := 1;
  823.       NewPage;
  824.       end;
  825.    write (outfile, LJS('', Margin) + id + copy (blnks, 1, 30 - length (id)));
  826.    PageLine := PageLine + 1;
  827. end;
  828.  
  829. {.pa}
  830. {-------------------------------------------------------------}
  831. FUNCTION RefsPerLine : INTEGER;
  832.  
  833. CONST
  834.   MaxLine = 132;
  835.  
  836. BEGIN
  837.   RefsPerLine := (MaxLine - MaxIdLen - Margin) DIV NumLen;
  838. END;
  839.  
  840.  
  841.  
  842. Procedure WriteNumber ( Number : integer);
  843. begin
  844.    if Nu > RefsPerLine then begin   { new line }
  845.       Nu := 1;
  846.       WriteId (' ');
  847.       end;
  848.    write (outfile, Number:NumLen);
  849.    Nu := Nu + 1;
  850. end;
  851.  
  852. {.pa}
  853. {-------------------------------------------------------------}
  854.  
  855. Procedure ReadTable;
  856. begin
  857.    Heading := 'Pascal CROSS REFERENCE';
  858.    WRITELN (OutFile);
  859.    NewPage;
  860.    ClearKey (Xref);
  861.    NextKey (xref, Nptr, Id); (* Skip $$eof$$ *)
  862.    NextKey (xref, Nptr, Id);
  863.    repeat
  864.       Nu:= 1;
  865.       NextNode := FirstNode [Nptr].Next;
  866.       if NextNode^.Data > 0 then begin
  867.          WriteId (id);
  868.          while NextNode <> nil do begin
  869.             WriteNumber (NextNode^.Data);
  870.             NextNode := NextNode^.Next;
  871.             end;
  872.          end;
  873.       NextKey (Xref, Nptr, Id);
  874.       Until not TreeOK;
  875. end;
  876.  
  877. {.pa}
  878. {-------------------------------------------------------------}
  879.  
  880. Procedure ReadStdIds;
  881. begin
  882.    Heading := 'Pascal STANDARD IDENTIFIERS';
  883.    WRITELN (OutFile);
  884.    NewPage;
  885.    ClearKey (Xref);
  886.    NextKey (xref, Nptr, Id); (* Skip $$eof$$ *)
  887.    NextKey (xref, Nptr, Id);
  888.    repeat
  889.       Nu:= 1;
  890.       NextNode := FirstNode [Nptr].Next;
  891.       if NextNode^.Data = -20 then begin
  892.          NextNode := NextNode^.Next;
  893.          if NextNode <> nil then begin
  894.             WriteId (id);
  895.             while NextNode <> nil do begin
  896.                WriteNumber (NextNode^.Data);
  897.                NextNode := NextNode^.Next;
  898.                end;
  899.             end;
  900.          end;
  901.       NextKey (Xref, Nptr, Id);
  902.       Until not TreeOK;
  903. end;
  904.  
  905. {.pa}
  906. {-------------------------------------------------------------}
  907.  
  908. Procedure ReadResvWds;
  909. begin
  910.    Heading := 'Pascal RESERVED WORDS';
  911.    WRITELN (OutFile);
  912.    NewPage;
  913.    ClearKey (Xref);
  914.    NextKey (xref, Nptr, Id); (* Skip $$eof$$ *)
  915.    NextKey (xref, Nptr, Id);
  916.    repeat
  917.       Nu:= 1;
  918.       NextNode := FirstNode [Nptr].Next;
  919.       if NextNode^.Data = -10 then begin
  920.          NextNode := NextNode^.Next;
  921.          if NextNode <> nil then begin
  922.             WriteId (id);
  923.             while NextNode <> nil do begin
  924.                WriteNumber (NextNode^.Data);
  925.                NextNode := NextNode^.Next;
  926.                end;
  927.             end;
  928.          end;
  929.       NextKey (Xref, Nptr, Id);
  930.       Until not TreeOK;
  931. end;
  932.  
  933. {.pa}
  934. {-------------------------------------------------------------}
  935.  
  936. procedure OpenIOFiles;
  937. var
  938.    LstFileName : IdStgType;
  939.    Temp        : STRING [128];
  940. begin
  941.    writeln ( 'Xreference Program.  Copyright (c) 1989 by DML Software Inc.  V'+ver);
  942.  
  943.    MainFileName := '';
  944.    LstFileName  := '';
  945.  
  946.    IF ParamCount >= 1 THEN
  947.       MainFileName := ParamStr(1);
  948.    IF ParamCount >= 2  THEN
  949.       LstFileName := ParamStr(2);
  950.  
  951.    Writeln('Input file: ',MainFileName);
  952.  
  953.    WHILE (MainFileName = '') OR (Not Exist (MainFileName)) DO BEGIN
  954.       writeln;
  955.       write( 'Input file ? ' );
  956.       readln( MainFileName );
  957.       IF MainFileName = '' THEN HALT (100);
  958.       END;
  959.  
  960.    Writeln ('Output file: ',LstFileName);
  961.  
  962.    WHILE (LstFileName = MainFileName) OR (LstFileName = '') DO BEGIN
  963.       writeln;
  964.       write ('Output file name? ');
  965.       readln (LstFileName);
  966.       IF LstFileName = '' THEN HALT (100);
  967.       END;
  968.  
  969.       assign  (outfile, LstFileName);
  970.       rewrite (outfile);
  971.  
  972. end;
  973.  
  974. {.pa}
  975. {-------------------------------------------------------------}
  976. PROCEDURE CheckPrinterType (VAR Compress, Normal : STRING);
  977.  
  978. VAR
  979.   PrtStr : STRING;
  980.   PrtCh  : CHAR;
  981.  
  982. BEGIN
  983.    IF ParamCount >= 3
  984.      THEN PrtStr := ParamStr(3)
  985.      ELSE PrtStr := '';
  986.    IF PrtStr = ''
  987.      THEN PrtCh := ' '
  988.      ELSE PrtCh := UPCASE(PrtStr[1]);
  989.    WRITELN('Printer Type: ',PrtCh);
  990.    WHILE NOT (PrtCh IN ['L','D','I']) DO BEGIN
  991.       WRITELN;
  992.       WRITE('Printer Type (L)aser, (D)atasouth, (I)bm): ');
  993.       READLN(PrtStr);
  994.       IF PrtStr = '' THEN HALT (100);
  995.       PrtCh := UPCASE(PrtStr[1]);
  996.      END;
  997.    CASE PrtCh OF
  998.      'L': BEGIN         { LASER }
  999.             Compress := ^[+'E'+^[+'(s0P'+^[+'(s16.6H'+^[+'(s8.5V';
  1000.             Normal   := ^[+'E';
  1001.             END;
  1002.      'D': BEGIN         { Data South 180 }
  1003.             Compress := ^O+^[+'[4w';   { 4 = 17cpi}
  1004.             Normal   := ^O+^[+'[2w';   { 2 = 12cpi, 0 = 10cpi }
  1005.             END;
  1006.      'I' : BEGIN          { IBM Graphics Printer }
  1007.              Compress    := ^O;
  1008.              Normal      := ^R;
  1009.            END;
  1010.      END;
  1011. END;
  1012.  
  1013. {.pa}
  1014. {-------------------------------------------------------------}
  1015.  
  1016. PROCEDURE CheckLangType (VAR LangType : BYTE);
  1017.  
  1018. VAR
  1019.   LangStr : STRING;
  1020.   LangCh  : CHAR;
  1021.  
  1022. BEGIN
  1023.    IF ParamCount >= 4
  1024.      THEN LangStr := ParamStr(4)
  1025.      ELSE LangStr := '';
  1026.    IF LangStr = ''
  1027.      THEN LangCh := ' '
  1028.      ELSE LangCh := UPCASE(LangStr[1]);
  1029.    WRITELN('Language Type: ',LangCh);
  1030.    WHILE NOT (LangCh IN ['T','M']) DO BEGIN
  1031.      WRITELN;
  1032.      WRITE('Language Type (T)urbo, (M)icrosoft Pascal: ');
  1033.      READLN(LangStr);
  1034.      IF LangStr = '' THEN HALT (100);
  1035.      LangCh := UPCASE(LangStr[1]);
  1036.      END;
  1037.    CASE LangCh OF
  1038.      'T' : LangType := 1;
  1039.      'M' : LangType := 2;
  1040.      END;
  1041. END;
  1042.  
  1043. {.pa}
  1044. {-------------------------------------------------------------}
  1045.  
  1046. Procedure InitVariables;
  1047. begin
  1048.    EndOfLine  := false;
  1049.    LineNumber := 1;
  1050.    PageNumber := 0;
  1051.    PageLine   := 1;
  1052.    outstg     := '';
  1053.    pntr       := MaxSec;
  1054.  
  1055.    FreeNptr   := 1;
  1056. end;
  1057.  
  1058. {.pa}
  1059. {-------------------------------------------------------------}
  1060.  
  1061. Procedure main;
  1062.  
  1063. VAR
  1064.   Seconds : REAL;
  1065.   DOSDateTime : T_DateTime;
  1066.   Compress  : STRING;
  1067.   Normal    : STRING;
  1068.  
  1069. begin
  1070.    Heading := '';
  1071.    Footing := '';
  1072.    Margin  := 0;
  1073.  
  1074. {   Today := GetDate + ' ' + GetTime; }
  1075.    GetDOSDateAndTime(Seconds,DOSDateTime);
  1076.    Today := Date2S(DOSDateTime,' WWW MM/DD/YY hh:mm:ss pm');
  1077.    OpenIOFiles;
  1078.    CheckPrinterType(Compress,Normal);
  1079.    CheckLangType(LangType);
  1080.    InitIndex;
  1081.    MakeIndex (Xref, 'Xref', 30, 0);
  1082.  
  1083.    InitVariables;
  1084.    InitResvWords;
  1085.    InitStdIds;
  1086.  
  1087.    writeln (outfile, Compress);             { BEGIN PRINTING }
  1088.    FileName := MainFileName;
  1089.    MainFileDateAndTime := GetFileDateAndTimeString (MainFileName);
  1090.  
  1091.    OpenInputFile (MainFileName, MainFile);
  1092.  
  1093.    Writeln ('Working ...');
  1094.  
  1095.    NewPage;
  1096.    write (outfile, LineNumber:5, ' ');
  1097.  
  1098.    MakeTable;
  1099.  
  1100.    Heading := '';
  1101.    Footing := '';
  1102.  
  1103.    ReadTable;
  1104.    ReadStdIds;
  1105.    ReadResvWds;
  1106.  
  1107.    writeln (outfile, ff, normal);           { END PRINTING }
  1108.  
  1109.    close (outfile);
  1110. end;
  1111.  
  1112. {$F+}
  1113. PROCEDURE ProgramExit;
  1114. BEGIN
  1115.   EXITPROC := ExitSave;
  1116.   IF (ERRORADDR <> NIL) OR (EXITCODE = 255) THEN BEGIN
  1117.     CLOSE(OutFile);
  1118.     WRITELN(^J^M,'Turbo Pascal Abend');
  1119.     END;
  1120. END;
  1121. {$F-}
  1122.  
  1123. PROCEDURE ExitInit;
  1124. BEGIN
  1125.   ExitSave := EXITPROC;
  1126.   EXITPROC := @ProgramExit;
  1127. END;
  1128.  
  1129. begin
  1130.   ExitInit;
  1131.   FILEMODE := 0;  { Read Only }
  1132.   TEXTCOLOR(LIGHTGRAY);
  1133.   main;
  1134. end.
  1135.  
  1136.